00100	(DEFUN CTRACE FEXPR (SPECS) (MAPCAR 'TRACE1 SPECS))
00200	
00300	
00400	(DEFUN CUNTRACE FEXPR (PROCNS)
00500	   (MAPCAR '(LAMBDA (PROCN)
00600	               (PROG (TFUNC)
00700	                  (SETQ TFUNC (GET PROCN 'CEXPR))
00800	                  (RETURN (COND ((AND TFUNC (EQ (CADR TFUNC) '"AUX"))
00900	                                 (PUTPROP PROCN (CDADR (CADAR (LAST (CADDR TFUNC)))) 'CEXPR)
01000	                                 PROCN)
01100	                                ('?)   ))))
01200	           PROCNS)   )
01300	
01400	
01500	(DEFUN TRACE1 (SPEC)
01600	   (PROG (PROCN OFUNC ARGL SPEC1)
01700	      (AND (ATOM SPEC)
01800	           (SETQ SPEC !"(@SPEC EN @'(DISPLAY *ARGS) EX @'(DISPLAY *VAL))))
01900	      (SETQ PROCN (CAR SPEC)
02000	            OFUNC (GET PROCN 'CEXPR))
02100	      (OR OFUNC (RETURN !"(@PROCN *NON FUNCTION*)))
02200	      (PUTPROP PROCN 
02300	               !"(@(SETQ ARGL (CAR OFUNC))
02400	                  "AUX" ((*ARGS @(ARGVALS ARGL))
02500	                         *VAL
02600	                         (*OFUNC '(CLAMBDA . @OFUNC)))
02700	                  !@(COND ((SETQ SPEC1 (MEMQ 'EN SPEC))
02800	                           !"((PRINT '(ENTERING @PROCN))
02900	                              . @(UPTONEXTATOM (CDR SPEC1))))   )
03000	                  (CSETQ *VAL (CEVAL !"(CALL *OFUNC . (@'/@ CALLCROCK '@ARGL))))
03100	                  !@(COND ((SETQ SPEC1 (MEMQ 'EX SPEC))
03200	                           !"((PRINT '(EXITING @PROCN))
03300	                              . @(UPTONEXTATOM (CDR SPEC1))))   )
03400	                  *VAL)
03500	               'CEXPR)
03600	      (RETURN PROCN)   ))(DEFUN CALLCROCK (DECLS)
03700	   (COND ((NULL DECLS) NIL)
03800	         ((EQ (CAR DECLS) '"OPTIONAL")
03900	          (CALLCROCK (CDR DECLS)))
04000	         ((EQ (CAR DECLS) '"REST")
04100	          ((LAMBDA (S)
04200	              (COND ((EQ (CAR S) 'RVALUE)
04300	                     (MAPCAR '(LAMBDA (V) !"(QUOTE @V)) (EVAL S)))
04400	                    (S)   ))
04500	           (CALLCROCK1 (CADR DECLS))))
04600	         ((CONS (CALLCROCK1 (CAR DECLS)) (CALLCROCK (CDR DECLS))))   ))
04700	
04800	
04900	(DEFUN CALLCROCK1 (DECL)
05000	   (COND ((ATOM DECL) !"(RVALUE '@DECL))
05100	         ((EQ (CAR DECL) 'QUOTE) (RVALUE (CADR DECL)))
05200	         ((ATOM (CAR DECL)) !"(RVALUE '@(CAR DECL)))
05300	         ((EQ (CAAR DECL) 'QUOTE) (RVALUE (CADAR DECL)))   ))
05400	
05500	
05600	(DEFUN ARGVALS (ARGL)
05700	   (CONS '/!"
05800	         (MAPCAN '(LAMBDA (DECL)
05900	                     (COND ((MEMQ DECL '("REST" "OPTIONAL")) ())
06000	                           ((LIST
06100	                             (LIST '/,
06200	                                   (COND ((ATOM DECL) DECL)
06300	                                         ((EQ (CAR DECL) 'QUOTE) (CADR DECL))
06400	                                         ((ATOM (CAR DECL)) (CAR DECL))
06500	                                         ((EQ (CAAR DECL) 'QUOTE) (CADAR DECL))   ))))   ))
06600	                 ARGL))   )
06700	
06800	
06900	(DEFUN UPTONEXTATOM (L)
07000	   (AND L (NOT (ATOM (CAR L))) (CONS (CAR L) (UPTONEXTATOM (CDR L))))   )
07100	
07200	
07300	(DEFUN DISPLAY FEXPR (ITEMS)
07400	   (MAPC '(LAMBDA (ITEM)
07500	             (CPRINT ITEM)
07600	             (PRINC '=/ )
07700	             (CPRIN1 (COND ((ATOM ITEM) (RVALUE ITEM)) ((EVAL ITEM))   )))
07800	   ITEMS))